perm filename QUAD.F4[MUS,LCS]2 blob
sn#098757 filedate 1974-04-23 generic text, type T, neo UTF8
00010 C QUAD CALL MUST BE IN 1ST OF 5 PARAMS. QUAD MUST BE FOLLOWED
00016 C BY SPC, / OR ;. OTHER CALLS SUCH AS MOVE,NUM ETC. CAN
00022 C APPEAR BEFORE / OR ;, BUT "ALL" MUST! APPEAR
00028 C BEFORE! QUAD (IF USED).
00030 C *** THE 5TH PARAM MUST NOT!! BE LISTED AT ALL IN YOUR SCORE!!! ****
00034 C ADD AN "F" TO QUAD FOR FUNCTIONS, AN "X" FOR X,Y COORDS.
00040 C BASIC QUAD PRODUCES CIRCLES. /DEGS/RADIUS/CENT. X/CENT. Y/
00046 C QUADX -- /X /Y / (5TH PARAM WILL ALWAYS BE WASTED)
00052 CC43611 IF(N.NE.'Q'.OR.INP(JD+1).NE.'U')GO TO 4361
00058 CC QX=-13.
00064 CC DO 43612 N=JD,72
00070 CC J=INP(N)
00076 CC IF(J.EQ.IXX)QX=QX-1.
00082 CC IF(J.EQ.IF)QX=QX-2.
00100 SUBROUTINE QUAD(NL)
00200 COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
00300 C INUM=INST# IPAR=PARAM#
00320 C BT=BASIC TIME P1 WHEN SUBROUTINE IS CALLED
00400 C IF IREST IS <0, THAT NOTE WILL BE A REST.
00500 C INST=INST. NAME, BG=INSTS' BEGIN TIMES.
00600 C NOTE #S IN SUBROUTINE: (1-84)
00620 C C4=37 FS4=43 C5=49 ETC. F1=86 F15=100 (NO F16!)
00700
00800 DIMENSION F(4,512),IP(1),ISU(1000),ALF(4),PATH(2,512),
00820 1 ICA(4),ICB(4),ARY(9)
00900 DATA ICA/-106,90,90,-106/,
01000 1 ICB/90,90,-106,-106/,ALF/'A','B','C','D'/
01050 1 , ARY/45H(' ARRAY F',I2,'(512); SEG(F',I2,');0 999') /
01055 C /DEG OR X/DIS OR Y/CEN OF CIRC X/CEN OF CIRCLE Y/(CALLS QUAD)/
01200 IF(CNT(INUM).GT.1.)GO TO 1
01400 L=0
01420 ARY(3)=5H',I1,
01500 NJ=IPAR-4
01525 XF=999.
01550 DIF=0
01575 DURFAC=(DUR(INUM)-P(1))/512.
01587 C WON'T CREATE FUNCS OF DPY FOR MORE THAN 1 INST
01595 1 CALL QUADO(P,IPAR,NL,XF,YF)
01600 DIF=DIF+P(2)
01610 IF(DIF)RETURN
01620 C GET ANOTHER NNTE FOR THIS FUNC. SLOT
01630 3 L=L+1
01800 M=0
01900 DO 4 K=NJ,IPAR-1
02000 M=M+1
02100 4 F(M,L)=P(K)
02200 PATH(1,L)=XF
02300 PATH(2,L)=YF
02400 IF(L.EQ.512)GO TO 2
02410 DIF=DIF-DURFAC
02420 IF(DIF.GE.0)GO TO 3
02430 C USE ANOTHER FUNC. SLOT FOR THIS NOTE
02440 RETURN
02450 C DUR SHOULD BE SET CLOSE TO "TRUE" DUR.
02500 2 CALL DPYSET(1,ISU,1000)
02600 CALL DPYBRT(2)
02700 CALL TYPLOC(150,-220)
02800 I=210
02900 J=506
03000 LB=250
03100 DO 5 K=1,2
03200 L=256
03300 IB=236
03400 JB=456
03500 DO 6 M=1,2
03600 CALL ALINE(I,L,J,L)
03700 C HORIZANTAL LINES
03800 CALL ALINE(LB,IB,LB,JB)
03900 C VERTICAL LINES
03910 DO 7 KB=LB+192,LB+64,-64
03920 7 CALL ALINE(KB,L,KB,IB)
03930 C SPACE MARKERS ON FUNC DPYS.
04000 L=-440
04100 IB=-460
04200 6 JB=-240
04300 LB=-466
04400 I=-486
04500 5 J=-210
04600
04700 CQ55 I=-480
04800 CQ J=460
04900 CQ DO 7 K=0,3
05000 CQ CALL DPYTXT(I,J,JF(K+1),1)
05100 CQ I=I+700
05200 CQ IF(K.NE.1)GO TO 7
05300 CQ I=-480
05400 CQ J=-J
05500 CQ7 CONTINUE
05600 CALL ALINE(-200,-200,200,200)
05700 CALL ALINE(-200,200,200,-200)
05750 C MARKS LISTENER POS.
05763
05776 A=6.
05789 L=0
05797 I=141.4
05801 J=-1
05805 140 IB=141.4*SIND(A)
05810 JB=141.4*COSD(A)
05812 IF(J.GE.0)GO TO 141
05815 CALL ALINE(L,I,IB,JB)
05820 141 A=A+6.
05821 J=J-1
05822 L=IB
05823 I=JB
05825 IF(A.LT.360.)GO TO 140
05830 C THE SPEAKER CIRCLE
05835
05895 CALL DPYBRT(5)
05897 CALL DPYBIG(5)
05900 DO 14 K=1,4
06000 14 CALL DPYTXT(ICA(K),ICB(K),ALF(K),1)
06100
06200 CALL DPYOUT(1)
06400
06500 77 M=1
06600 IB=-466
06700 J=256
06800 DO 8 K=NJ,IPAR-1
06900 CALL AIVECT(IB,IFIX(F(M,1)*200.0)+J)
07000 DO 9 L=4,512,3
07100 I=IB+L/2
07200 C REDUCES TO FIT 1/4 OF SCREEN
07300 JB=F(M,L)*200.0+J
07400 99 CALL AVECT(I,JB)
07500 9 LB=0
07600 M=M+1
07700 IB=250
07800 IF(M.EQ.3)J=-440
07900 IF(M.EQ.4)IB=-466
08000 8 CONTINUE
08100
08200 CQ CALL DPYOUT(1)
08400 CALL AIVECT(IFIX(PATH(1,1)*10.0),IFIX(PATH(2,1)*10.0))
08500 DO 13 K=4,512,3
08600 I=PATH(1,K)*10.
08700 JB=PATH(2,K)*10.
08800 IF(IABS(JB).GT.512.OR.IABS(I).GT.512)GO TO 13
08900 CALL AVECT(I,JB)
09000 13 CONTINUE
09100 CALL DPYOUT(1)
09300 TYPE 112
09400 ACCEPT 113,NAME,LB
09420 333 IF(NAME.NE.'PLOT')GO TO 130
09440 C JUMP IF NOT SAVING DPY BUFFER
09460 IP(1)=IP(3)+2
09480 C IP(3) IS REALLY ISU(2). I.E. WDCNT
09490 CALL SAVB(IP)
09495 C WRITES A BINARY FILE OF DPY BUFFER FOR "PLTVEC"
09500 130 IF(NAME.EQ.' '.OR.MOD(NL,2).NE.0)RETURN
09510 C RETURN IF QUAD OR QUADX(-13,-15)
09520 C WRITE FUNCS IF QUADF OR QUADFX (-14,-16)
09600 REWIND 23
09700 CALL OFILE(23,NAME)
09800 DO 10 K=1,4
09900 IF(NJ.GE.10)ARY(3)=5H',I2,
10000 WRITE(23,ARY)NJ,NJ
10300 101 WRITE(23,12)(F(K,N),N=1,512)
10400 10 NJ=NJ+1
10500 END FILE 23
10520 TYPE 114,NAME
10600 RETURN
10900 12 FORMAT(16F8.5/)
11000 112 FORMAT(' TYPE OUTPUT FILE NAME'/)
11100 113 FORMAT(A5,I)
11120 114 FORMAT(' FUNCTIONS ARE IN ',A5,'.DAT'/)
11200 END